home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / cmpnew / cmpif.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  14KB  |  367 lines
  1. ;;; CMPIF  Conditionals.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'if 'c1if 'c1special)
  10. (si:putprop 'if 'c2if 'c2)
  11. (si:putprop 'and 'c1and 'c1)
  12. (si:putprop 'and 'c2and 'c2)
  13. (si:putprop 'or 'c1or 'c1)
  14. (si:putprop 'or 'c2or 'c2)
  15.  
  16. (si:putprop 'jump-true 'set-jump-true 'set-loc)
  17. (si:putprop 'jump-false 'set-jump-false 'set-loc)
  18.  
  19. (si:putprop 'case 'c1case 'c1)
  20. (si:putprop 'ecase 'c1ecase 'c1)
  21. (si:putprop 'case 'c2case 'c2)
  22.  
  23. (defun c1if (args &aux info f)
  24.   (when (or (endp args) (endp (cdr args)))
  25.         (too-few-args 'if 2 (length args)))
  26.   (unless (or (endp (cddr args)) (endp (cdddr args)))
  27.           (too-many-args 'if 3 (length args)))
  28.   (setq f (c1fmla-constant (car args)))
  29.   (case f
  30.         ((t) (c1expr (cadr args)))
  31.         ((nil) (if (endp (cddr args)) (c1nil) (c1expr (caddr args))))
  32.         (otherwise
  33.          (setq info (make-info))
  34.          (list 'if info
  35.                (c1fmla f info)
  36.                (c1expr* (cadr args) info)
  37.                (if (endp (cddr args)) (c1nil) (c1expr* (caddr args) info)))))
  38.   )
  39.  
  40. (defun c1fmla-constant (fmla &aux f)
  41.   (cond
  42.    ((consp fmla)
  43.     (case (car fmla)
  44.           (and (do ((fl (cdr fmla) (cdr fl)))
  45.                    ((endp fl) t)
  46.                    (declare (object fl))
  47.                    (setq f (c1fmla-constant (car fl)))
  48.                    (case f
  49.                          ((t))
  50.                          ((nil) (return nil))
  51.                          (t (if (endp (cdr fl))
  52.                                 (return f)
  53.                                   (return (list* 'and f (cdr fl))))))))
  54.           (or (do ((fl (cdr fmla) (cdr fl)))
  55.                   ((endp fl) nil)
  56.                   (declare (object fl))
  57.                   (setq f (c1fmla-constant (car fl)))
  58.                   (case f
  59.                         ((t) (return t))
  60.                         ((nil))
  61.                         (t (if (endp (cdr fl))
  62.                                (return f)
  63.                                (return (list* 'or f (cdr fl))))))))
  64.           ((not null)
  65.            (when (endp (cdr fmla)) (too-few-args 'not 1 0))
  66.            (unless (endp (cddr fmla))
  67.                    (too-many-args 'not 1 (length (cdr fmla))))
  68.            (setq f (c1fmla-constant (cadr fmla)))
  69.            (case f
  70.                  ((t) nil)
  71.                  ((nil) t)
  72.                  (t (list 'not f))))
  73.           (t fmla)))
  74.    ((symbolp fmla) (if (constantp fmla)
  75.                        (if (symbol-value fmla) t nil)
  76.                        fmla))
  77.    (t nil))
  78.   )
  79.  
  80. (defun c1fmla (fmla info)
  81.   (if (consp fmla)
  82.       (case (car fmla)
  83.             (and (case (length (cdr fmla))
  84.                    (0 (c1t))
  85.                    (1 (c1fmla (cadr fmla) info))
  86.                    (t (cons 'FMLA-AND
  87.                             (mapcar #'(lambda (x) (c1fmla x info))
  88.                                     (cdr fmla))))))
  89.             (or (case (length (cdr fmla))
  90.                    (0 (c1nil))
  91.                    (1 (c1fmla (cadr fmla) info))
  92.                    (t (cons 'FMLA-OR
  93.                             (mapcar #'(lambda (x) (c1fmla x info))
  94.                                     (cdr fmla))))))
  95.             ((not null)
  96.                   (when (endp (cdr fmla)) (too-few-args 'not 1 0))
  97.                   (unless (endp (cddr fmla))
  98.                           (too-many-args 'not 1 (length (cdr fmla))))
  99.                   (list 'FMLA-NOT (c1fmla (cadr fmla) info)))
  100.             (t (c1expr* fmla info)))
  101.       (c1expr* fmla info))
  102.   )
  103.  
  104. (defun c2if (fmla form1 form2
  105.                   &aux (Tlabel (next-label)) Flabel)
  106.   (cond ((and (eq (car form2) 'LOCATION)
  107.               (null (caddr form2))
  108.               (eq *value-to-go* 'TRASH)
  109.               (not (eq *exit* 'RETURN)))
  110.          (let ((exit *exit*)
  111.                (*unwind-exit* (cons Tlabel *unwind-exit*))
  112.                (*exit* Tlabel))
  113.               (CJF fmla Tlabel exit))
  114.          (wt-label Tlabel)
  115.          (c2expr form1))
  116.         (t
  117.          (setq Flabel (next-label))
  118.          (let ((*unwind-exit* (cons Flabel (cons Tlabel *unwind-exit*)))
  119.                (*exit* Tlabel))
  120.               (CJF fmla Tlabel Flabel))
  121.          (wt-label Tlabel)
  122.          (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr form1))
  123.          (wt-label Flabel)
  124.          (c2expr form2)))
  125.   )
  126.  
  127. ;;; If fmla is true, jump to Tlabel.  If false, do nothing.
  128. (defun CJT (fmla Tlabel Flabel)
  129.   (case (car fmla)
  130.     (fmla-and (do ((fs (cdr fmla) (cdr fs)))
  131.                   ((endp (cdr fs))
  132.                    (CJT (car fs) Tlabel Flabel))
  133.                   (declare (object fs))
  134.                   (let* ((label (next-label))
  135.                          (*unwind-exit* (cons label *unwind-exit*)))
  136.                         (CJF (car fs) label Flabel)
  137.                         (wt-label label))))
  138.     (fmla-or (do ((fs (cdr fmla) (cdr fs)))
  139.                  ((endp (cdr fs))
  140.                   (CJT (car fs) Tlabel Flabel))
  141.                  (declare (object fs))
  142.                  (let* ((label (next-label))
  143.                         (*unwind-exit* (cons label *unwind-exit*)))
  144.                        (CJT (car fs) Tlabel label)
  145.                        (wt-label label))))
  146.     (fmla-not (CJF (cadr fmla) Flabel Tlabel))
  147.     (LOCATION
  148.      (case (caddr fmla)
  149.            ((t) (unwind-no-exit Tlabel) (wt-nl) (wt-go Tlabel))
  150.            ((nil))
  151.            (t (let ((*value-to-go* (list 'jump-true Tlabel)))
  152.                    (c2expr* fmla)))))
  153.     (t (let ((*value-to-go* (list 'jump-true Tlabel))) (c2expr* fmla))))
  154.   )
  155.  
  156. ;;; If fmla is false, jump to Flabel.  If true, do nothing.
  157. (defun CJF (fmla Tlabel Flabel)
  158.   (case (car fmla)
  159.     (FMLA-AND (do ((fs (cdr fmla) (cdr fs)))
  160.                   ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel))
  161.                   (declare (object fs))
  162.                   (let* ((label (next-label))
  163.                          (*unwind-exit* (cons label *unwind-exit*)))
  164.                         (CJF (car fs) label Flabel)
  165.                         (wt-label label))))
  166.     (FMLA-OR (do ((fs (cdr fmla) (cdr fs)))
  167.                  ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel))
  168.                  (declare (object fs))
  169.                  (let* ((label (next-label))
  170.                         (*unwind-exit* (cons label *unwind-exit*)))
  171.                        (CJT (car fs) Tlabel label)
  172.                        (wt-label label))))
  173.     (FMLA-NOT (CJT (cadr fmla) Flabel Tlabel))
  174.     (LOCATION
  175.      (case (caddr fmla)
  176.            ((t))
  177.            ((nil) (unwind-no-exit Flabel) (wt-nl) (wt-go Flabel))
  178.            (t (let ((*value-to-go* (list 'jump-false Flabel)))
  179.                    (c2expr* fmla)))))
  180.     (t (let ((*value-to-go* (list 'jump-false Flabel))) (c2expr* fmla))))
  181.   )
  182.  
  183. (defun c1and (args)
  184.   (cond ((endp args) (c1t))
  185.         ((endp (cdr args)) (c1expr (car args)))
  186.         (t (let ((info (make-info))) (list 'AND info (c1args args info))))))
  187.  
  188. (defun c2and (forms)
  189.   (do ((forms forms (cdr forms)))
  190.       ((endp (cdr forms))
  191.        (c2expr (car forms)))
  192.       (declare (object forms))
  193.       (cond ((eq (caar forms) 'LOCATION)
  194.              (case (caddar forms)
  195.                    ((t))
  196.                    ((nil) (unwind-exit nil 'JUMP))
  197.                    (t (wt-nl "if(" (caddar forms) "==Cnil){")
  198.                       (unwind-exit nil 'JUMP) (wt "}")
  199.                       )))
  200.             ((eq (caar forms) 'VAR)
  201.              (wt-nl "if(")
  202.              (wt-var (car (caddar forms)) (cadr (caddar forms)))
  203.              (wt "==Cnil){")
  204.              (unwind-exit nil 'jump) (wt "}"))
  205.             (t
  206.              (let* ((label (next-label))
  207.                     (*unwind-exit* (cons label *unwind-exit*)))
  208.                    (let ((*value-to-go* (list 'jump-true label)))
  209.                         (c2expr* (car forms)))
  210.                    (unwind-exit nil 'jump)
  211.                    (wt-label label))))
  212.       ))
  213.  
  214. (defun c1or (args)
  215.   (cond ((endp args) (c1nil))
  216.         ((endp (cdr args)) (c1expr (car args)))
  217.         (t (let ((info (make-info)))
  218.                 (list 'OR info (c1args args info))))))
  219.  
  220. (defun c2or (forms &aux (*vs* *vs*))
  221.   (do ((forms forms (cdr forms))
  222.        (temp (list 'vs (vs-push))))
  223.       ((endp (cdr forms))
  224.        (c2expr (car forms)))
  225.       (declare (object forms))
  226.       (cond ((eq (caar forms) 'LOCATION)
  227.              (case (caddar forms)
  228.                    ((t) (unwind-exit t 'JUMP))
  229.                    ((nil))
  230.                    (t (wt-nl "if(" (caddar forms) "!=Cnil){")
  231.                       (unwind-exit (caddar forms) 'JUMP) (wt "}"))))
  232.             ((eq (caar forms) 'VAR)
  233.              (wt-nl "if(")
  234.              (wt-var (car (caddar forms)) (cadr (caddar forms)))
  235.              (wt "!=Cnil){")
  236.              (unwind-exit (cons 'VAR (caddar forms)) 'jump) (wt "}"))
  237.             ((and (eq (caar forms) 'CALL-GLOBAL)
  238.                   (get (caddar forms) 'predicate))
  239.              (let* ((label (next-label))
  240.                     (*unwind-exit* (cons label *unwind-exit*)))
  241.                    (let ((*value-to-go* (list 'jump-false label)))
  242.                         (c2expr* (car forms)))
  243.                    (unwind-exit t 'jump)
  244.                    (wt-label label)))
  245.             (t
  246.              (let* ((label (next-label))
  247.                     (*unwind-exit* (cons label *unwind-exit*)))
  248.                    (let ((*value-to-go* temp)) (c2expr* (car forms)))
  249.                    (wt-nl "if(" temp "==Cnil)") (wt-go label)
  250.                    (unwind-exit temp 'jump)
  251.                    (wt-label label))))
  252.       )
  253.   )
  254.  
  255. (defun set-jump-true (loc label)
  256.   (unless (null loc)
  257.     (cond ((eq loc t))
  258.           ((and (consp loc) (eq (car loc) 'INLINE-COND))
  259.            (wt-nl "if(")
  260.            (wt-inline-loc (caddr loc) (cadddr loc))
  261.            (wt ")"))
  262.           (t (wt-nl "if((" loc ")!=Cnil)")))
  263.     (unless (eq loc t) (wt "{"))
  264.     (unwind-no-exit label)
  265.     (wt-nl) (wt-go label)
  266.     (unless (eq loc t) (wt "}")))
  267.   )
  268.  
  269. (defun set-jump-false (loc label)
  270.   (unless (eq loc t)
  271.     (cond ((null loc))
  272.           ((and (consp loc) (eq (car loc) 'INLINE-COND))
  273.            (wt-nl "if(!(")
  274.            (wt-inline-loc (caddr loc) (cadddr loc))
  275.            (wt "))"))
  276.           (t (wt-nl "if((" loc ")==Cnil)")))
  277.     (unless (null loc) (wt "{"))
  278.     (unwind-no-exit label)
  279.     (wt-nl) (wt-go label)
  280.     (unless (null loc) (wt "}")))
  281.   )
  282.  
  283. (defun c1ecase (args) (c1case args t))  
  284.  
  285. (defun c1case (args &optional (default nil))
  286.   (when (endp args) (too-few-args 'case 1 0))
  287.   (let* ((info (make-info))
  288.          (key-form (c1expr* (car args) info))
  289.          (clauses nil))
  290.     (dolist (clause (cdr args))
  291.       (cmpck (endp clause) "The CASE clause ~S is illegal." clause)
  292.       (case (car clause)
  293.             ((nil))
  294.             ((t otherwise)
  295.              (when default
  296.                    (cmperr (if (eq default 't)
  297.                                "ECASE had an OTHERWISE clause."
  298.                                "CASE had more than one OTHERWISE clauses.")))
  299.              (setq default (c1progn (cdr clause)))
  300.              (add-info info (cadr default)))
  301.             (t (let* ((keylist
  302.                        (cond ((consp (car clause))
  303.                               (mapcar #'(lambda (key) (if (symbolp key) key
  304.                                                           (add-object key)))
  305.                                       (car clause)))
  306.                              ((symbolp (car clause)) (list (car clause)))
  307.                              (t (list (add-object (car clause))))))
  308.                       (body (c1progn (cdr clause))))
  309.                  (add-info info (cadr body))
  310.                  (push (cons keylist body) clauses)))))
  311.     (list 'case info key-form (reverse clauses) (or default (c1nil)))))
  312.  
  313. (defun c2case (key-form clauses default
  314.                &aux (cvar (next-cvar)) (*vs* *vs*) (*inline-blocks* 0))
  315.   (setq key-form (car (inline-args (list key-form) '(t))))
  316.   (wt-nl "{object V" cvar "= " key-form ";")
  317.  
  318.   (dolist (clause clauses)
  319.     (let* ((label (next-label))
  320.            (keylist (car clause))
  321.            (local-label nil))
  322.       (do ()
  323.           ((<= (length keylist) 5))
  324.         (when (null local-label) (setq local-label (next-label)))
  325.         (wt-nl "if(")
  326.         (dotimes (i 5)
  327.           (cond ((symbolp (car keylist))
  328.                  (wt "(V" cvar "== ")
  329.                  (case (car keylist)
  330.                    ((t) (wt "Ct"))
  331.                    ((nil) (wt "Cnil"))
  332.                    (otherwise (wt "VV[" (add-symbol (car keylist)) "]")))
  333.                  (wt ")"))
  334.                 (t (wt "eql(V" cvar ",VV[" (car keylist) "])")))
  335.           (when (< i 4) (wt-nl "|| "))
  336.           (pop keylist))
  337.         (wt ")")
  338.         (wt-go local-label))
  339.  
  340.       (wt-nl "if(")
  341.       (do ()
  342.           ((endp keylist))
  343.         (cond ((symbolp (car keylist))
  344.                (wt "(V" cvar "!= ")
  345.                (case (car keylist)
  346.                  ((t) (wt "Ct"))
  347.                  ((nil) (wt "Cnil"))
  348.                  (otherwise (wt "VV[" (add-symbol (car keylist)) "]")))
  349.                (wt ")"))
  350.               (t (wt "!eql(V" cvar ",VV[" (car keylist) "])")))
  351.         (unless (endp (cdr keylist)) (wt-nl "&& "))
  352.         (pop keylist))
  353.       (wt ")")
  354.       (wt-go label)
  355.       (when local-label (wt-label local-label))
  356.       (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr (cdr clause)))
  357.       (wt-label label)))
  358.  
  359.   (if (eq default 't)
  360.       (wt-nl "FEerror(\"The ECASE key value ~s is illegal.\",1,V" cvar ");")
  361.       (c2expr default))
  362.  
  363.   (wt "}")
  364.   (close-inline-blocks))
  365.  
  366.  
  367.